!TODO posun tento modul do ineho file-u

MODULE utilities

CONTAINS

    SUBROUTINE parsing(string, token, output)

        CHARACTER ( len = * ), INTENT (IN) :: 					            string
        CHARACTER ( len = 1 ), INTENT (IN) :: 					            token
        CHARACTER ( len = * ), ALLOCATABLE, DIMENSION (:), INTENT (OUT) :: 	output

        INTEGER :: 								pos1 = 1, 	&
										        pos2, 		&
										        n = 0

!TODO chyba vracia to na konci jeden medzernik

        DO
            pos2 = INDEX(string(pos1:), token)
            IF (pos2 == 0) THEN
                n = n + 1
                EXIT
            END IF
            IF (pos2 == 1) THEN
                pos1 = pos2+pos1
            ELSE
                n = n + 1
                pos1 = pos2+pos1
            ENDIF
        END DO

        ALLOCATE (output(n))

        n = 0
        pos1 = 1

        DO
            pos2 = INDEX(string(pos1:), token)
            IF (pos2 == 0) THEN
                n = n + 1
                output(n) = string(pos1:)
                EXIT
            END IF
            IF (pos2 == 1) THEN
                pos1 = pos2+pos1
            ELSE
                n = n + 1
                output(n) = string(pos1:pos1+pos2-2)
                pos1 = pos2+pos1
            ENDIF
        END DO

    END SUBROUTINE parsing

END MODULE utilities

!####################################################
!#                                                  #
!#  Program :       Showme                          #
!#  Versia  :       0.1                             #
!#  Ucel    :       Prekladac vystupnych suborov    #
!#                  VASP-u POSCAR a vystupnych      #
!#                  suborov VASP-u CONTCAR          #
!#                  do formatu .XYZ                 #
!#                                                  #
!####################################################

PROGRAM showme

    USE UTILITIES
    USE IFPORT

    IMPLICIT NONE

    INTEGER, PARAMETER :: 		    dbl = SELECTED_REAL_KIND ( 14, 200 )
    REAL(dbl), PARAMETER :: 		pi = 3.141592653589793_dbl, zero = 0.d0
    REAL(dbl) :: 			        scale_
    INTEGER :: 				        i, 				            &
					                number_of_arguments, 		&
					                run_type = 0, 		    	&
					                op_i, 			        	&
					                staty = 0, 		        	&
					                imax=4,		        		&
					                jmax=4,		        		&
					                kmax=4
    CHARACTER ( len = 200 ) :: 		temp0,				&
					                temp1,				&
					                temp3, 				&
					                argument, 			&
					                op

    TYPE cell_type
        REAL ( dbl ), DIMENSION ( 3, 3 ) :: hmat
        REAL ( dbl ), DIMENSION ( 3, 3 ) :: h_inv
        REAL ( dbl ) :: deth
    END TYPE cell_type

    TYPE at
        REAL(dbl), DIMENSION (3) :: r
        REAL(dbl), DIMENSION (3) :: frac
        CHARACTER (len=2) :: alabel_dlp
    END TYPE at

    TYPE ( cell_type ) :: 			box
    TYPE(at), ALLOCATABLE, DIMENSION (:) :: 	atom
    TYPE(at), ALLOCATABLE, DIMENSION (:) :: 	atom_R

    number_of_arguments = iargc()

    IF (number_of_arguments == 0) THEN

        CALL Load_file("CONTCAR")

    ELSE

        DO i = 1, number_of_arguments

            CALL getarg(i,argument)

            CALL work(argument)

        END DO

        SELECT CASE (run_type)

        CASE (1)

            WRITE (*,*) "run_type 1"
            WRITE (temp3,*) "CONTCAR.", TRIM(op)
            CALL load_file(temp3)

        CASE DEFAULT

            CALL Load_file("CONTCAR")

        END SELECT

    ENDIF

    CALL calc
!    CALL GXYZ
!    CALL CELL
    CALL create_lattice
    CALL open_viewer

    STOP

!############### END OF PROGRAM ###############

!##############################################
!# CONTAINS                                   #
!##############################################

CONTAINS

    SUBROUTINE fill_atom(temp_0,temp_1)

        CHARACTER ( len = 200 ), INTENT (in) ::		 	        temp_0,		&
								                                temp_1
        CHARACTER ( len = 2 ), ALLOCATABLE, DIMENSION (:) :: 	elem,		&
								num
        INTEGER, ALLOCATABLE, DIMENSION (:) :: 			        numbers
        INTEGER :: 						                        r, 		&
								                                i,		&
                                                                j, 		&
								                                k, 		&
								                                n_at

        CALL parsing(temp_0," ",elem)
        CALL parsing(temp_1," ",num)


        ALLOCATE (numbers ( SIZE(num) - 1))

        n_at = 0
        DO i = 1, (SIZE(num) - 1)

            READ (num(i),*, IOSTAT = r) numbers(i)

            n_at = n_at + numbers(i)

        END DO

        ALLOCATE (atom(n_at))
        ALLOCATE (atom_R(n_at*imax*jmax*kmax))

        k = 1

        DO i = 1, (SIZE(elem) - 1)
            DO j = 1, numbers(i)

                atom(k) % alabel_dlp = elem(i)
                k = k + 1

            END DO
        END DO

    END SUBROUTINE fill_atom

    SUBROUTINE load_file(load)

        CHARACTER ( len = * ), INTENT (in) :: 	load
        CHARACTER ( len = 250 ) ::              fic_msg
        INTEGER :: 				                LF = 12,	&
						                        res

        WRITE (*,*) "opening ", TRIM(load)

        OPEN    (UNIT = LF, FILE = TRIM(load), ACTION = "READ", STATUS = 'old', IOSTAT = res)

        IF ( res > 0 ) THEN

            WRITE (*,*) TRIM(LOAD), " is missing"
            WRITE (*,*) "Stopping"

            STOP

        ENDIF

        res = 0

        WRITE(fic_msg,*) TRIM(load), " is corrupted"

        !TODO intel fortran ma dake exception handling nastuduj a prerob nasledujuci kod

        READ(LF,*, IOSTAT = res)
        CALL error_msg(res, fic_msg)
        READ(LF,*, IOSTAT = res) scale_
        CALL error_msg(res, fic_msg)
        READ(LF,*, IOSTAT = res) box % hmat(1,1), box % hmat(2,1), box % hmat(3,1)
        CALL error_msg(res, fic_msg)
        READ(LF,*, IOSTAT = res) box % hmat(1,2), box % hmat(2,2), box % hmat(3,2)
        CALL error_msg(res, fic_msg)
        READ(LF,*, IOSTAT = res) box % hmat(1,3), box % hmat(2,3), box % hmat(3,3)
        CALL error_msg(res, fic_msg)
        READ(LF,"(a10)", IOSTAT = res) temp0
        CALL error_msg(res, fic_msg)
        READ(LF,"(a10)", IOSTAT = res) temp1
        CALL error_msg(res, fic_msg)
        READ(LF,*, IOSTAT = res)
        CALL error_msg(res, fic_msg)

        CALL fill_atom(temp0,temp1)

        DO i = 1, SIZE(atom)

            READ (12,*) atom(i) % frac

        END DO

        CLOSE(LF)

    END SUBROUTINE

    SUBROUTINE work(arg)

        CHARACTER ( len = * ), INTENT (in) :: 		arg
        INTEGER :: 					                res, 	&
							                        n

        SELECT CASE (staty)

            CASE (0)

                READ (arg,*,IOSTAT = res) op_i

                IF (res == 0) THEN

                    READ (arg,*,IOSTAT = res) op
                    run_type = 1

                ENDIF

                IF (arg(1:1) == "-") THEN
                    IF (arg(2:2) == "n") THEN
                        staty = 1
                    END IF
                END IF

            CASE (1)

                READ (arg,*,IOSTAT = res) n

                imax = n
                jmax = n
                kmax = n

                staty = 0

        END SELECT


    END SUBROUTINE

    SUBROUTINE calc

        REAL(8), DIMENSION(3), PARAMETER :: 		x=(/1.d0,0.d0,0.d0/),		&
							                        y=(/0.d0,1.d0,0.d0/),		&
							                        z=(/0.d0,0.d0,1.d0/)
        REAL(8), DIMENSION(3) :: 			        rc,			            	&
							                        aa,				            &
							                        bb,			               	&
							                        cc, 	        			&
							                        pos
        INTEGER :: 					                i,			            	&
							                        j,		            		&
                                                    k,			            	&
                                                    l,			            	&
							                        m
        REAL(8), ALLOCATABLE :: 			        rb(:,:),	        		&
							                        ratom(:,:)

        box % hmat = box % hmat * scale_

        DO i = 1, SIZE (atom)

            atom(i) % r = MATMUL(box % hmat, atom(i) % frac)

        END DO

        m = 1

        DO i = 0 , imax - 1

            DO j = 0, jmax - 1

                DO k = 0, kmax - 1

                    pos = i * box % hmat(:,1)
                    pos = pos + j * box % hmat(:,2)
                    pos = pos + k * box % hmat(:,3)

                    DO l = 1, SIZE (atom)

                        atom_R(m) % alabel_dlp = atom(l) % alabel_dlp
                        atom_R(m) % r = pos + atom(l) % r

                        m = m + 1

                    END DO
                END DO
            END DO
        END DO


    END SUBROUTINE

    SUBROUTINE GXYZ

    OPEN(11,file='GXYZ')

    WRITE (11,*) SIZE(atom)
    WRITE (11,*)

    DO i = 1, SIZE(atom)

        WRITE (11,'(a2,5x,3(f10.4,2x))') atom(i) % alabel_dlp, atom(i) % r

    END DO

    CLOSE (11)

    END SUBROUTINE GXYZ

    SUBROUTINE CELL

        OPEN(10,file='CELL')
        WRITE(10,*) box % hmat(1,1),box % hmat(2,1),box % hmat(3,1)
        WRITE(10,*) box % hmat(1,2),box % hmat(2,2),box % hmat(3,2)
        WRITE(10,*) box % hmat(1,3),box % hmat(2,3),box % hmat(3,3)
        CLOSE(10)

    END SUBROUTINE CELL

    SUBROUTINE create_lattice

        INTEGER :: lattice = 56

        OPEN(lattice,file='lattice.xyz')
        WRITE(lattice,*) SIZE(atom_R)
        WRITE(lattice,*)
        DO i = 1,SIZE(atom_R)
            WRITE(lattice,"(a2,2x,3(f10.3,2x))") atom_R(i) % alabel_dlp, atom_R(i) % r
        END DO
        CLOSE(lattice)

    END SUBROUTINE create_lattice

    SUBROUTINE open_viewer

        INTEGER :: r

        WRITE(*,*)'# of atoms = ', SIZE(atom)
	WRITE(*,*)'# of replicated atoms = ', SIZE(atom_R)

        r = system("xmakemol -f lattice.xyz &")

        STOP

    END SUBROUTINE open_viewer

    SUBROUTINE alt_OV

        INTEGER :: r
        
        r = system('xmakemol -f - &')
        WRITE(*,*) SIZE(atom_R)
        WRITE(*,*)
        DO i = 1,SIZE(atom_R)
            WRITE(*,"(a2,2x,3(f10.3,2x))") atom_R(i) % alabel_dlp, atom_R(i) % r
        END DO

    END SUBROUTINE alt_OV

    SUBROUTINE error_msg(res, error)

        INTEGER, INTENT ( in )                      ::  res
        CHARACTER ( len = 250 ), INTENT ( in )      ::  error

        IF (res /= 0) THEN

            WRITE(*,*) TRIM(error)
            WRITE(*,*) "Stopping"

            STOP

        ENDIF

    END SUBROUTINE

END PROGRAM showme

